perm filename SCANX.F4[SCR,MUS]3 blob
sn#544850 filedate 1980-11-06 generic text, type T, neo UTF8
00100 C ***** SCANNER *************************
00200 C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,POINTR,PARAM,ALL 7/78
00300 SUBROUTINE SCANR
00400 COMMON /PCIP/ PCH(27,102),IPT(27,101)
00500 COMMON/P/P(1) /PL/PL(1)
00600
00700 DIMENSION IP(1)
00800 COMMON J,L,CNT(27),BT,MK,DF,DUR(27)
00900 1/E/IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
01000 1 ,INP(145),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
01100 EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
01200 1 ,(IEN,ISCA(4)),(IP,PL),(I0,IDAT),(I9,IDAT(10)),(IPP,ISCA(2))
01300 C 2/74 IP IS NOW EQUIV TO PL! USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
01400 C WILL THIS DO ANYTHING TO MUSIC5 VERSION??
01500 NNUM=-1
01600 ISKP=0
01700 JJ=0
01800 XMINUS=1.
01900 KPAR=0
02000 999 IDECI=-1
02100 M=0
02200 2799 N=INP(ML)
02300 IF(N.NE.IQT)GO TO 899
02400 JA=-1
02500 ML=ML+1
02600 ISUB=8
02700 JJ=JJ+1
02800 VX(JJ)=ML
02900 C POINTS TO FIRST LIT. CHAR.
03000 DO 1177 K=ML,144
03100 IF(INP(K).NE.IQT)GO TO 1177
03200 ML=K+1
03300 2177 N=INP(ML)
03400 GO TO 899
03500 1177 CONTINUE
03600 C SKIPS 'LIT' ITEMS IN RAN. SELECTION
03700 899 ML=ML+1
03800 IF(N.EQ.':')GO TO 751
03900 IF(N.EQ.ISEMI)GO TO 751
04000 IF(N.NE.IBLA)GO TO 510
04100 4702 IF(ISKP)202,2799,2799
04200
04300 510 IF(N.NE.IPP)GO TO 4511
04400 C CATCH PARAM NUMS. GO UP AND CHANGE TO MAGIC NUMBER.
04500 K=INP(ML)
04600 IF(K.LT.I0.OR.K.GT.I9)GO TO 4511
04700 KPAR=-1
04800 JA=0
04900 C JA=0 SO SCANR WILL FIND NOTES OR NUMS LATER.
05000 GO TO 2177
05100 4511 IF(JA)GO TO 70
05200 CCCC510 IF(JA)GO TO 70
05300 C********** MAY 22,71
05400 DO 77 K=1,12
05500 IF(N.NE.ISCA(K))GO TO 77
05600 IF(K.EQ.2)GO TO 1511
05700 CX IF(K.NE.2)GO TO 1510
05800 C P=PROXIMITY MODE -- OR A PARAM NUM.
05900 CX3511 N=INP(ML)
06000 CX IF(N.GE.I0.AND.N.LE.I9)GO TO 2511
06100 CCCC IF(N.LT.I0.OR.N.GT.I9)GO TO 1511
06200 CX IF(JA.GE.0)CALL ERR(6)
06300 C ERROR IF NO NUM AFTER P WHEN ONLY NUMS ARE EXPECTED.
06400 CX GO TO 1511
06500 CX2511 KPAR=-1
06600 C FINDS PARAMETER NUMBER (E.G. P13) USED AS A SIMPLE NUMBER. (KPAR IS FLAG)
06700 CX GO TO 2177
06800 1510 IF(K.NE.4)GO TO 511
06900 C K=2=P, =4=O ('ORDINARY')
07000 1511 NSWCH=K-4
07100 GO TO 2177
07200 C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
07300 C ************ MAY 22,71
07400 511 NNUM=K
07500 JJ=JJ+1
07600 NFLG=-1
07700 N=INP(ML)
07800 IF(N.NE.IF)GO TO 410
07900 NNUM=NNUM-1
08000 GO TO 610
08100 410 IF(N.NE.ISS)GO TO 3410
08200 NNUM=NNUM+1
08300 610 ML=ML+1
08400 N=INP(ML)
08500 3410 IF(N.EQ.IEN)GO TO 3411
08600 IF(N.NE.'I')GO TO 371
08700 C 'END' OR 'FINE' WILL END INST.
08800 C******** MAY 20,71
08900 3411 VX(JJ)=-10000.
09000 CIRC3411 VX(JJ)=10000.
09100 IF(DUR(LK))DUR(LK)=10000.
09200 IAMP=-1
09300 RETURN
09400 371 IF(N.EQ.ISEMI)GO TO 5410
09500 IF(N.EQ.IBLA)GO TO 5410
09600 DO 177 KN=1,10
09700 IF(N.NE.IDAT(KN))GO TO 177
09800 CC IF(KN.GE.9)CALL ERR(4)
09900 C FOUND OCTAVE NUM. >8 -- TOO HIGH! ***** OK TO 9 NOW 7/78
10000 JSCA=KN-1
10100 CC JSCA=KN-2
10200 ML=ML+1
10300 GO TO 2410
10400 177 CONTINUE
10500 GO TO 6410
10600 5410 KN=-1
10700 6410 IF(NSWCH.EQ.0)GO TO 2410
10800 IF(KN)GO TO 7410
10900 CC IF(N.EQ.'+')NOLD=NOLD+6
11000 CC IF(N.EQ.'-')NOLD=NOLD-6
11100 C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
11200 7410 IF(NOLD-NNUM.LE.5)GO TO 7411
11300 IF(JSCA.LT.7)JSCA=JSCA+1
11400 7411 IF(NOLD-NNUM.GE.-5)GO TO 2410
11500 IF(JSCA.GT.0)JSCA=JSCA-1
11600 C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
11700 2410 VX(JJ)=JSCA*12+NNUM
11800 CCC2410 VX(JJ)=JSCA*12+NNUM
11900 NOLD=NNUM
12000 C ********** MAY 22,71
12100 4410 NNUM=-2
12200 IF(INP(ML).EQ.ISEMI)RETURN
12300 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
12400 IF(N.EQ.IXX)GO TO 210
12500 IF(N.EQ.'*')GO TO 210
12600 GO TO 310
12700 C *********MAY 22,71
12800 77 CONTINUE
12900 70 IF(N.NE.'-')GO TO 71
13000 XMINUS=-1.
13100 GO TO 2799
13200 210 JJ=JJ+1
13300 IF(JJ.EQ.1)GO TO 3310
13400 C****** MAY 19,71
13500 XMINUS=1.
13600 VX(JJ)=0
13700 C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
13800 GO TO 310
13900 71 IF(N.EQ.IXX)GO TO 210
14000 IF(N.EQ.'*')GO TO 210
14100 IF(N.EQ.'R')GO TO 73
14200 CXX IF(N.EQ.IPP)GO TO 3511
14300 C CATCH PARAM NUMS. GO UP AND CHANGE TO MAGIC NUMBER.
14400
14500 1410 DO 78 K=1,11
14600 IF(N.NE.IDAT(K))GO TO 78
14700 ISKP=-1
14800 IF(N.NE.IDOT)GO TO 79
14900 IDECI=M
15000 GO TO 75
15100 79 M=M+1
15200 IP(M)=K-1
15300 GO TO 75
15400 78 CONTINUE
15500 IF(N.NE.IE)GO TO 8811
15600 IF(INP(ML).NE.IEN)GO TO 781
15700 GO TO 7811
15800 8811 IF(N.NE.IF)GO TO 781
15900 IF(INP(ML).NE.'I')GO TO 781
16000 C 'EN(D)' OR 'FI(NE)' WILL END INST.
16100 7811 JJ=1
16200 GO TO 3411
16300 781 IF(N.EQ.'/')N=ISEMI
16400 C FOR MOTIVIC TRANFORMATIONS
16500
16600 75 KN=INP(ML)
16700 CXX IF(KN.NE.'R')GO TO 275
16800 CXX IF(INP(ML+1).NE.IE)GO TO 175
16900 C NOW FOUND A 'REP'
17000 CXX ML=ML+2
17100 CXX GO TO 202
17200 275 IF(KN.NE.IXX)GO TO 175
17300 CC IF(INP(ML+1).NE.'(')GO TO 202
17400 C "X(" STARTS A 'MOTIF' BUT "X (" WON'T WORK!!!!
17500 IF(M.NE.0)GO TO 202
17600 175 IF(KN.EQ.'*')GO TO 202
17700 C FOR 2X3, 2*3, ETC. CHECK THIS OUT. 6/74
17800 CC75 IF(INP(ML).NE.IXX)GO TO 752
17900 CC ML=ML-1
18000 CC GO TO 202
18100 C FOR 'X' AND '*' WITHOUT SPACES.
18200 IF(N.EQ.ISEMI)GO TO 751
18300 IF(KN.EQ.IQT)GO TO 751
18400 C SO YOU CAN TYPE .5"F7" ETC. (NO SPACE)
18500 IF(KN.NE.1)GO TO 2799
18600 C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
18700 751 IF(ISKP.EQ.0)RETURN
18800 202 IF(IDECI.NE.-1)GO TO 302
18900 IDECI=0
19000 GO TO 402
19100 302 IDECI=M-IDECI
19200 402 KN=0
19300 IEXP=M-1
19400 IF(M.LT.1)M=1
19500 DO 171 K=1,M
19600 KV=10**IEXP
19700 IF(IEXP.EQ.0)KV=1
19800 KN=KN+IP(K)*KV
19900 171 IEXP=IEXP-1
20000 A=10**IDECI
20100 IF(IDECI.EQ.0)A=1.
20200 JJ=JJ+1
20300 A=KN/A*XMINUS
20400 CC VX(JJ)=KN/A*XMINUS
20500 IF(KPAR.EQ.0)GO TO 172
20600 A=-9999.-A/100.
20700 KPAR=0
20800 C CHANGES P13 TO -9999.13, FOR EXAMPLE.
20900 172 VX(JJ)=A
21000 IF(ISUB.EQ.1)RETURN
21100 IF(CODE.NE.-22.)XMINUS=1.
21200 C ONLY ONE - NEEDED FOR RHY.COMPOSITE
21300 1310 IF(INP(ML).NE.1)GO TO 310
21400 VX(JJ+1)=VX(JJ)*2.
21500 JJ=JJ+1
21600 ML=ML+1
21700 GO TO 1310
21800 206 ML=ML+2
21900 3310 VX(1)=-99.
22000 C******** MAY 19,71
22100 310 ISKP=0
22200 IF(N.NE.ISEMI)GO TO 999
22300
22400 RETURN
22500 73 JJ=JJ+1
22600 IF(INP(ML).EQ.IE)GO TO 206
22700 C NEXT IS FOR A REST ('R')
22800 VX(JJ)=199.
22900 CCC VX(JJ)=85.
23000 C 7/75 GO TO 4410
23100 731 N=INP(ML)
23200 IF(N.EQ.'/')RETURN
23300 IF(N.EQ.ISEMI)RETURN
23400 IF(N.NE.IBLA)GO TO 899
23500 ML=ML+1
23600 GO TO 731
23700 END
23800
23900 SUBROUTINE BGSORT(BW)
24000 C THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
24100 C ALLOWS 100 BG TIMES.
24200 COMMON /Q/ BNW(200),NWZ
24300 C****NEEDS TRAP FOR EXCEEDING 200 LIMIT ⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗
24400 DO 5308 K=1,NWZ
24500 X=BNW(K)-.0001
24600 Y=X+.0002
24700 C ROUND-OFF NONSENSE
24800 IF(BW.LE.X)GO TO 5308
24900 IF(BW.LT.Y)RETURN
25000 5308 CONTINUE
25100 NWZ=NWZ+1
25200 BNW(NWZ)=BW
25300 RETURN
25400 END
25500
25600 SUBROUTINE FMT(JFM,INP,MLX)
25700 DIMENSION JFM(3),INP(1)
25800 DO 1 MLX=2,72
25900 J=INP(MLX)
26000 IF(J.EQ.' ')J=' '
26100 C ABOVE FINDS A TAB, CHANGES IT TO BLANK SPACE
26200 IF(J.EQ.' ')GO TO 2
26300 IF(J.EQ.',')GO TO 2
26400 IF(J.EQ.';')GO TO 2
26500 1 CONTINUE
26600 C*** TEMPORARY CHANGE ***** IF(J.EQ.':')GO TO 3
26700 C SPACE=COMMA=SPACE, ALSO STOPS ON ";"
26800 3 CALL ERR(1)
26900 C ERROR IF COLON IS FOUND OR THERE IS NO END MARK
27000 2 MLX=MLX+1
27100 IF(MLX.GT.7)MLX=7
27200 JFM(2)='0'+(MLX-2)*536870912
27300 C FINDS NUMBER FOR 'A' FORMAT
27400 END
27500
27600 SUBROUTINE RANR(VX,K)
27700 C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE AND ADDS .999
27800 DIMENSION VX(1)
27900 CC X=VX(K)
28000 CC Y=VX(K+1)
28100 CC IF(X.GT.Y)VX(K)=X+.999
28200 CC IF(Y.GE.X)VX(K+1)=Y+.999
28300 J=K+1
28400 IF(VX(K).GT.VX(K+1))J=J-1
28500 IF(VX(J).GT.-9999.)VX(J)=VX(J)+.999
28600 C AVOID TAMPERING WITH PARAM NUMS.
28700 END
28800
28900 SUBROUTINE SQYY(YY,X,Y,Z)
29000 YY=2.*Z/(X+Y)
29100 IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
29200 RETURN
29300 END
29400
29500 SUBROUTINE COLTTY(JNP,JT)
29600 COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED /FRMT/J(2)
29700 DIMENSION JNP(1)
29800 DATA J(2)/'80A1)'/
29900 DO 1 K=72,1,-1
30000 JJ=JNP(K)
30100 1 IF(JJ.NE.' '.AND.JJ.NE.' ')GO TO 2
30200 C SECOND SPACE IS A TAB.
30300 K=1
30400 2 IF(JT.EQ.21)GO TO 3
30500 J(1)=' (1X'
30600 IF(LN.EQ.0)GO TO 5
30700 J(1)='(I6,X'
30800 WRITE(JT,J)LN,(JNP(L),L=1,K)
30900 RETURN
31000 3 J(1)=' ('
31100 5 WRITE(JT,J)(JNP(L),L=1,K)
31200 END
31300
31400 FUNCTION READER(JNP)
31500 DIMENSION JNP(80)
31600 COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
31700 1 /FRMT/J(2) /IFI/IFI
31800 DATA TPALN/20H(' TYPE A LINE'/) /
31900 J(1)=' ('
32000 READER=0
32100 IF(ITYP)GO TO 1
32200 6 TYPE TPALN
32300 ACCEPT J,JNP
32400 IF(JED)CALL COLTTY(JNP,21)
32500 GO TO 8
32600 CC1 IF(IFI)GO TO 5
32700 1 IF(LN.NE.0)GO TO 5
32800 READ(23,J,END=3)JNP
32900 GO TO 7
33000 3 READER=-1
33100 GO TO 8
33200 5 J(1)=' (I,'
33300 READ(23,J,END=3)LN,JNP
33400 7 IF(SOS)CALL COLTTY(JNP,JOUT)
33500 8 IF(JNP(1).EQ.' ')JNP(1)=' '
33600 C CHANGES TAB TO SPACE ABOVE.
33700 END
33800
33900 SUBROUTINE QUAD
34000 C DUMMY -- FOR NOW. 7/74
34100 END
34200
34300 FUNCTION RMOVX(W,Y,Z)
34400 IF(W.EQ.0)W=.01
34500 IF(Y.EQ.0)Y=.01
34600 RMOVX=Y*((W/Y)**Z)
34700 END
34800
34900 SUBROUTINE CLEAN(LEND)
35000 COMMON /E/IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,
35100 1 IXX,ISEMI,IQT
35200 1 ,INP(145),VX(70),ISCA(12),IDAT(11),IAMP,J,KN,O,ML,CODE,IBLA
35300 DATA LA/"605004020100/,LZ/"751004020100/,MAG/"200000000000/
35400 CC ↑↑↑↑DATA LA/'a'/, LZ/'z'/, MAG/'a'-'A'/
35500 C CLEAR THE END OF ARRAY
35600 M=72
35700 LEND=-1
35800 K=0
35900 DO 10 LL=73,80
36000 IF(INP(LL).EQ.' ')GO TO 10
36100 C THIS 'ERR' IS JUST A WARNING
36200 CALL ERR(11)
36300 GO TO 1
36400 10 CONTINUE
36500 1 K=K+1
36600 NN=INP(K)
36700 IF(NN.EQ.';')GO TO 2
36800 IF(NN.EQ.'/')GO TO 2
36900 IF(NN.EQ.'<')GO TO 3
37000 CCC IF(NN.NE.'<')GO TO 5
37100 CCC INP(K)=' '
37200 CCC GO TO 3
37300 C USE < FOR COMMENT-- AS IN MUS10
37400 5 IF(NN.EQ.','.OR.NN.EQ.' ')INP(K)=' '
37500 CHANGE ALL COMMAS AND TABS TO BLANKS(IT LOOKS LIKE A BLANK ABOVE, BUT ISN'T)
37600 C**** FOR CHORD FEATURE IF(NN.EQ.':')CALL ERR(1)
37700 8 IF(NN.NE.'"')GO TO 4
37800 7 K=K+1
37900 IF(INP(K).EQ.'"')GO TO 4
38000 IF(K.LT.M)GO TO 7
38100 CALL ERR(5)
38200 2 LEND=K
38300 4 IF(K.LT.M)GO TO 1
38400 3 IF(LEND.EQ.0)GO TO 9
38500 DO 11 K=1,LEND
38600 NN=INP(K)
38700 11 IF(NN.GE.LA.AND.NN.LE.LZ)INP(K)=NN-MAG
38800 C ABOVE CHANGES LOWER CASE LETTERS TO UPPER.
38900 IF(LEND.GT.0)RETURN
39000 CCCCCC RETURN
39100 9 IF(M.EQ.145)CALL ERR(2)
39200 C LINES STARTING WITH P OR C CAN POSSIBLY HAVE NO SEMICOLON IN THEM.
39300 CC IF(INP(1).NE.'P'.AND.INP(1).NE.'C')CALL ERR(2)
39400 6 CALL READER(INP(74))
39500 C GO READ ANOTHER LINE.
39600 M=INP(74)
39700 IF(M.GE.'A'.AND.M.LE.'Z')CALL ERR(2)
39800 C ONE EXTRA SPACE (M=145, NOT 144) FOR THE CRLF.
39900 M=145
40000 K=72
40100 INP(73)=' '
40200 GO TO 1
40300 END
40400
40500 SUBROUTINE ERR(K)
40600 COMMON /ERRFLG/ERRFLG /TYP/SOS,JOUT /E/IQ(27),ISKP,XMINUS,N,
40700 1 IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT,INP(74)
40800 IF(SOS.EQ.0)TYPE 999,INP
40900 GO TO(1,2,3,4,5,6,7,8,9,10,11,12,13)K
41000 TYPE 199,K
41100 199 FORMAT(' ***** ERROR!! SOMEWHERE UP TO HERE. ***-FATAL-***'/)
41200 GO TO 200
41300 1 TYPE 101
41400 GO TO 200
41500 101 FORMAT(' ***** COLON WANTED HERE? ***-FATAL-***'/)
41600 CCC11 FORMAT(/' ILLEGAL COLON')
41700 2 TYPE 102
41800 GO TO 200
41900 102 FORMAT(' ***** NO END MARK OR SEMICOLON ***-FATAL-***'/)
42000 3 TYPE 103
42100 GO TO 200
42200 103 FORMAT(' ***** MORE THAN 2 PARENS OPEN ***-FATAL-***'/)
42300 4 TYPE 104
42400 GO TO 200
42500 104 FORMAT(' ***** SOME NUMBER OUT OF BOUNDS ***-FATAL-***'/)
42600 5 TYPE 105
42700 GO TO 200
42800 105 FORMAT(' ***** OPEN QUOTES ***-FATAL-***'/)
42900 6 TYPE 106
43000 GO TO 200
43100 106 FORMAT(' ***** PARAM NUMBER ERROR: >99 ***-FATAL-***'/)
43200 7 TYPE 107
43300 GO TO 200
43400 107 FORMAT(' ***** TOO MANY INSTS ***-FATAL-***'/)
43500 8 TYPE 108
43600 GO TO 200
43700 108 FORMAT(' ***** MOTIVE ERROR ***-FATAL-***'/)
43800 9 TYPE 109
43900 GO TO 200
44000 109 FORMAT(' ***** "MOVE" ERROR ***-FATAL-***'/)
44100 10 TYPE 110
44200 GO TO 200
44300 110 FORMAT(' ***** MISSING "*" ***-FATAL-***'/)
44400 11 TYPE 111
44500 RETURN
44600 111 FORMAT(' **** WARNING: CHARACTERS FOUND BEYOND COLUMN 72'/)
44700 12 TYPE 112
44800 GO TO 200
44900 999 FORMAT(1X74A1)
45000 112 FORMAT(
45100 1' ***** WRONG NUM. OF ELEMENTS IN RAN. SELECTION. ***-FATAL-***'/)
45200 13 TYPE 113
45300 113 FORMAT(' ***** WRONG FORMAT FOR P2. ***-FATAL-***'/)
45400 200 ERRFLG=-1
45500 C THIS WILL CAUSE EXIT BEFORE 'RUNIT'.
45600 END
45700
45800 SUBROUTINE ACCEL
45900 COMMON /PCIP/ PCH(27,102),IPT(27,101)
46000 COMMON/P/P(1) /PL/PL(1)
46100
46200 COMMON/VV/LIMIT,V(1)/A/ROFF(27),NP(27),
46300 1 RDEV(27),XT(27),OTH(20,16),P1(27),JFM(4),IFM(80)
46400 1 ,FINM(6),TINST(5),ENFI(5),TEDIT(4),INVIS(27)
46500 COMMON J,L,CNT(27),BT,MK,DF,DUR(27)
46600 1/E/IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
46700 1 ,INP(145),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
46800 COMMON/B/MOT,PR,T5,NINS,I,RA,KZY,NWX,INONLY,MX,
46900 1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
47000 1 ZZ,CHN,YY
47100 1 /C/LPAR,IPRN,QX,RETRO,INVRT,ICON,LCNT,
47200 1 PARENS,JZ,BY,MLX,IZ,ALL,JD,LEND,QTS,ITMP,
47300 1 LP,ILIT,NLIT,KTMP,IC,NONO,RD,IA
47400 C /C/=26
47500 IF(T5.EQ.1)GO TO 4020
47600 XA=RA
47700 7020 RA=V(IA+K)
47800 IF(RA.EQ.-10000.)RETURN
47900 4020 RD=1
48000 IF(RA.LT.0)RD=-1.
48100 RA=RA*RD
48200 IF(KA.EQ.0)RA=RA-RC
48300 W=RA
48400 RB=W
48500 IF(W.LE.Z-.0001)GO TO 2020
48600 C .0001 FOR ROUND-OFF ERRORS!!!!!!!
48700 IF(Z.NE.0)GO TO 3020
48800 RA=RA/Y
48900 RB=-1.
49000 RC=0
49100 GO TO 8020
49200 3020 W=Z
49300 RC=W+RC
49400 GO TO 24
49500 2020 RC=0
49600 24 IF(X.NE.Y)GO TO 424
49700 RA=W/X
49800 GO TO 8020
49900 C DUR OF TMP + BG TIME OF TMP - NOTE VALUE -
50000 C BG TIME OF NOTE. CHN=TBG.
50100 424 RAX=XT(J)
50200 RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
50300 XT(J)=RAX+YY*RA
50400 8020 IF(KA.EQ.0)RA=RA+XA
50500 KA=1
50600 CXX IF(RC.NE.0)GO TO 1011
50700 CCXX IF(T5.EQ.1)RETURN
50800 IF(T5.NE.1)GO TO 1012
50900 IF(RC.NE.0)GO TO 2011
51000 RETURN
51100 C T5=1 IN 'RUNIT'
51200 1012 V(IA+K)=RA*RD
51300 IF(K.EQ.IZ)RETURN
51400 C*********** JUNE 1,71
51500 1011 IF(T5.EQ.1)GO TO 2011
51600 K=K+1
51700 IF(ZZ.NE.0)Z=Z-W
51800 IF(Z.GT.0)GO TO 7020
51900 IF(RB.EQ.-1.)GO TO 7020
52000 IC=IC+1
52100 IF(RB.EQ.W)RETURN
52200 KA=0
52300 K=K-1
52400 RETURN
52500 2011 XA=RA
52600 IF(K.GT.1)GO TO 9020
52700 K=I-6
52800 ZPAR=-9900.-CHN-ZZ
52900 DO 3011 KL=8,I
53000 IF(V(K).NE.ZPAR)GO TO 3011
53100 IF(V(K+1).EQ.990000.)GO TO 9020
53200 3011 K=K-1
53300 9020 W=ZZ
53400 IF(V(K+3))K=K+3
53500 C ABOVE IS FOR TYPED IN TEMPO CHANGES
53600 KA=K+3
53700 ZZ=V(KA)
53800 C DUR OF NEXT TEMPI
53900 X=V(KA+1)
54000 Y=V(KA+2)
54100 213 KA=0
54200 Z=ZZ
54300 CALL SQYY(YY,X,Y,Z)
54400 CHN=CHN+W
54500 XT(J)=X
54600 IF(KA.EQ.1)Z=0
54700 RA=PR
54800 KA=0
54900 K=K+3
55000 GO TO 4020
55100 END
55200
55300 SUBROUTINE POINTR(INUM,IPAR,ISTRT,KODE)
55400 COMMON/VV/LIMIT, V(2000)
55500 C TO FIND POINTERS TO LISTS, ETC. IN V ARRAY WHEN USING SUBR.
55600 C KODES: -22=RHY -33=NOTES -44=NUMS -46=RLIST -36=RNOTES
55700 C -11=SUBN -12=SUBR -55=MOVE NUMS -56=MOVE NOTES
55800 C -66=DUPL -88=LIT -57=MOVE RANGE NUMS -58=MOVE RNG NOTES
55900 DO 1 K=1,2000
56000 N=V(K)
56100 IF(N.LT.10000)GO TO 1
56200 IF(N/10000.NE.INUM)GO TO 1
56300 IF(MOD(N,10000).NE.IPAR)GO TO 1
56400 ISTRT=K+4
56500 KODE=V(K+2)
56600 ICNT=V(K+3)
56700 IF(IABS(KODE).LT.11)ISTRT=ISTRT-1
56800 RETURN
56900 C FINDS FIRST OCCURRENCE OF PARAM AND INST ONLY.
57000 1 CONTINUE
57100 END
57200
57300 CC SUBROUTINE NMCHG
57400 CC DIMENSION RNAME(5),JNM(5)
57500 CC COMMON /INS/ INST(27),BG(60)
57600 CC COMMON P(30),INUM,IPAR,CNT(27),BT,PL(48),IREST,DF,DUR(27)
57700 CC COMMON/VV/LIMIT, V(1) /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,IL
57800 CC 1,KODE,NPAR,LP,TBG,AC,NPA,BX,IDF,PM,NM,PAR,PX2,T1,RD,VIJ2
57900 CC EQUIVALENCE (RNAME,JNM)
58000 CC DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
58100 CC DATA MM/"774000000000/
58200
58300 CC P(IPAR)=0
58400 C REPLACE NAME BY A ZERO FOR THIS PARAM.
58500 CC PL(IPAR)=1.
58600 CC J=PM-1
58700 C PM POINTS TO 1ST WORD OF LIT. STRING., PAR= LAST
58800 CC N=V(J)
58900 C THE WORD COUNT
59000 CC DO 15 K=1,5
59100 CC J=J+1
59200 CC X=V(J)
59300 CC IF(K.GT.N)X=' '
59400 CC15 RNAME(K)=X
59500 C N=WDCNT OF INST NAME
59600 CC NN=0
59700 CC DO 10 K=5,1,-1
59800 CC NN=NN .OR. (JNM(K) .AND. MM)
59900 CC IF (K-1) 20,20,17
60000 CC17 IF (NN.GE.0)GO TO 13
60100 CC NN = (( NN .AND. LL)/KK) .OR. JJ
60200 CC GO TO 10
60300 CC13 NN = NN / KK
60400 CC10 CONTINUE
60500 CC20 INST(INUM)=NN
60600 CC END
60700
60800 SUBROUTINE SHORT(KNP,K)
60900 C DON'T TYPE TRAILING BLANKS
61000 DIMENSION KNP(1)
61100 DO 1 K=15,1,-1
61200 1 IF(KNP(K).NE.' ')RETURN
61300 K=1
61400 END
61500
61600 C***** THIS IS NOW A 'FAIL' ROUTINE IN SPRINT.FAI
61700 CC FUNCTION PARAM(X,K)
61800 CC COMMON J,L /P/P(1) /PL/PL(1) /C/T,NWZZ,IT3,T6,NW,TDUR,A,
61900 CC 1 T2,T4,BY,KODE,NPAR,LP,TBG,AC,NPA,BX,IDF,PM,NM,PAR,PX2
62000 CC K=0
62100 C IF K IS NOT ZERO UPON RETURN, THEN WE'VE FOUND INFO IN OTHER PARAM.
62200 CC PARAM=X
62300 CC IF(X.GT.-9999.0)RETURN
62400 CC IF(X.EQ.-10000.0)RETURN
62500 CC K=-(X+9999.0)*100.+.1
62600 CC PARAM=P(K)
62700 C GET DATA FROM PARAM K
62800 CC PM=PL(K)
62900 CC IF(L.NE.2)RETURN
63000 C L=CALLING PARAM NUM., K=PARAM REFERRED TO.
63100 CC IF(K.EQ.2)PARAM=PX2
63200 C MUST USE 'UNPROCESSED' FORM OF P2 (I.E. NO 'TEMPO' CHANGES)
63300 CC END
63400
63500 C***** MICROTONES ********
63600 SUBROUTINE MICRO
63700 COMMON INUM,IPAR /P/P(1) /PL/PL(1)
63800 C CALL SUBROUTINE FROM ANY PARAMETER WHERE THE CALLING PARAMETER
63900 C AND THE IMMEDITELY PRECEDING PARAMETER ARE UNUSED BY YOUR INSTR.
64000 C P3 CAN BE NOTES OR NUMBS.
64100
64200 X=P(3)
64300 IF(PL(3).EQ.1)GO TO 1
64400 CC X=IFIX(X)
64500 C FOR RAND NOTES TO LOCK ON NOTE NUMBERS.
64600 CC X=30.8677*2**(X/12)
64700 X=15.43385*2**(X/12)
64800 C X=FREQ. IN HZ. BASED ON NT # IN P3. NUM. ABOVE IS B, IE. LOWEST B -1 OCT.
64900 PL(3)=1.
65000 C THIS CAUSES FREQ. NUM TO PRINT INSTEAD OF LITERAL CHARACTERS.
65100
65200 1 Y=IFIX(P(IPAR-1))
65300 Z=IFIX(P(IPAR))
65400 C FIX NEEDED BECAUSE OF POSSIBLE NON-INTEGERS HERE.
65500 P(3)=X*2**(Y/Z)
65600 C IPAR (Z) IS THE CALLING PARAMETER. IPAR-1 (Y) THE PREVIOUS PARAM.
65700 C X HAS BASE FREQ.
65800 C THE NUMBER IN P(IPAR)=# OF DIVISIONS OF THE OCTAVE.
65900 C THE NUMBER IN P(IPAR-1)=CHROMATIC STEP IN THAT DIV.
66000 END
66100
66200 FUNCTION ALL(JPT,IPTX)
66300 COMMON /VV/LIMIT,V(1)
66400 DIMENSION JPT(1)
66500 K=IPTX-1
66600 IF(K.GT.0)GO TO 2
66700 1 K=JPT(-K)
66800 IF(K)GO TO 1
66900 C FOR 'ALL' WITH RR,RD,DF. FOLLOWS UP ON POINTERS TO POINTERS!
67000 K=K-1
67100 2 ALL=PARAM(V(K+3),K)
67200 END
67300
67400 C THIS ROUTINE ALLOWS NAMES OF FROM 1 TO 5 LETTERS TO BE USED.
67500 C NO EXTENSIONS CAN BE USED. INF RETURNS INFO REL LINE NUMS.
67600 CC SUBROUTINE IFILE(I,N,INF)
67700 CC EQUIVALENCE (NN,NAME),(NN2,NN(2))
67800 CC COMMON /NN/NN(2)
67900 CC DOUBLE PRECISION NAME
68000 CC DATA NN(2)/'.'/
68100 CC5 INF=0
68200 CC NN(1)=N
68300 CC OPEN(UNIT=I,FILE=NAME)
68400 CC IF(NN2.NE.'.')GO TO 1
68500 C JUMP IF COMING FROM OFILE CALL
68600 CC READ(I,2)K,J
68700 CC IF(K.NE.'00')GO TO 3
68800 CC INF=-1
68900 C INF = -1 = LINE NUMBERS.
69000 CC6 OPEN(UNIT=I,FILE=NAME)
69100 C REOPEN IF LINE NUMS OR NO "COMMENT"
69200 CC GO TO 1
69300 CC3 IF(K.NE.'CO')GO TO 6
69400 CC IF(J.NE.'MMENT')GO TO 6
69500 CC4 READ(I,2)K,J
69600 C READS COMMENTS ON DIRECTORY PAGE.
69700 CC IF(J.NE.';')GO TO 4
69800 CC2 FORMAT(A2,A5)
69900 CC1 NN2='.'
70000 CC END
70100 CC SUBROUTINE OFILE(I,N,IEXT)
70200 CC COMMON /NN/NN1,NN2
70300 CC NN2=IEXT
70400 CC CALL IFILE(I,N,INF)
70500 CC END